;;; $Id: log.sld 60 2012-07-19 07:23:40Z alan.watson.f $

(define-library (oaxaca log)

  (export log-info
          log-warning
          log-error)

  (import (scheme base)
          (scheme process-context)
          (scheme write))

  (begin

    (define (log-error-object level error-object)
      (log level (error-object-message error-object))
      (case (length (error-object-irritants error-object))
        ((0))
        ((1)
         (log level "irritant is:")
         (log level (lambda () (write (car (error-object-irritants error-object))))))
        (else
         (log level "irritants are:")
         (for-each
          (lambda (irritant)
            (log level (lambda () (write irritant))))
          (error-object-irritants error-object)))))

    (define (log level message . rest)
      (if (and (error-object? message) (null? rest))
        (log-error-object level message)
        (let ((rest-string
               (parameterize ((current-output-port (open-output-string)))
                 (for-each
                  (lambda (x)
                    (if (procedure? x)
                      (x)
                      (display x)))
                  rest)
                 (display "\n")
                 (get-output-string (current-output-port)))))
          (display level (current-error-port))
          (display ": " (current-error-port))
          (display message (current-error-port))
          (display rest-string (current-error-port))
          (flush-output-port (current-error-port)))))

    (define (log-info message . rest)
      (apply log "info" message rest))

    (define (log-warning message . rest)
      (apply log "WARNING" message rest))

    (define (log-error message . rest)
      (apply log "ERROR" message rest))))
